home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swag9502.zip / XX3402.ZIP / XX34SRC.ZIP / XX3402.PAS < prev   
Pascal/Delphi Source File  |  1994-01-28  |  71KB  |  1,826 lines
  1.  
  2. (******************************************************************************)
  3. (*                                                                            *)
  4. (* TITLE   : XX3402 ver 0.2                                                   *)
  5. (*                                                                            *)
  6. (* AUTHOR  : Guy McLoughlin                                                   *)
  7. (*                                                                            *)
  8. (* DATE    : January 28, 1994                                                 *)
  9. (*                                                                            *)
  10. (* PURPOSE : Modified XX encoder/decoder.                                     *)
  11. (*                                                                            *)
  12. (* NOTES   : XX3402.PAS source-code released to the public domain.            *)
  13. (*           This source-code requires Edwin T. Floyd's public domain         *)
  14. (*           (see author's notes) CRC.PAS unit to compile.                    *)
  15. (*                                                                            *)
  16. (******************************************************************************)
  17.  
  18.               (* Compiler directives.                                         *)
  19.  {$I COMP.SET}
  20.  {$M 4096, 32768, 131072}
  21.  
  22. program Xx3402;
  23. uses
  24.   dos,
  25.   crc;
  26.  
  27. (********************** START OF GLOBAL DATA DEFINITIONS **********************)
  28.  
  29. type
  30.   T_Ch2  = array[1..2]  of char;
  31.   T_Ch3  = array[1..3]  of char;
  32.   T_Ch4  = array[1..4]  of char;
  33.   T_Ch5  = array[1..5]  of char;
  34.   T_Ch6  = array[1..6]  of char;
  35.   T_Ch7  = array[1..7]  of char;
  36.   T_Ch8  = array[1..8]  of char;
  37.   T_Ch10 = array[1..10] of char;
  38.   T_Ch12 = array[1..12] of char;
  39.   T_Ch14 = array[1..14] of char;
  40.   T_Ch27 = array[1..27] of char;
  41.   T_Ch62 = array[1..62] of char;
  42.   T_Ch64 = array[0..63] of char;
  43.  
  44.   T_By256 = array[0..255] of byte;
  45.   T_Wo255 = array[1..255] of word;
  46.   T_Lo255 = array[1..255] of longint;
  47.  
  48.   T_St2  = string[2];
  49.   T_St3  = string[3];
  50.   T_St8  = string[8];
  51.   T_St12 = string[12];
  52.   T_St20 = string[20];
  53.  
  54.   T_3Ch2 = array[1..3] of T_Ch2;
  55.  
  56.   T_By80 = array[43..122] of byte;
  57.  
  58.   T_Header1 = T_Ch62;
  59.  
  60.   T_Header2 = record
  61.                 Spacer0  : T_Ch8;
  62.                 Size     : T_Ch6;
  63.                 Spacer1  : char;
  64.                 Fday     : T_Ch2;
  65.                 Fmonth   : T_Ch2;
  66.                 Fyear    : T_Ch2;
  67.                 Spacer2  : char;
  68.                 FCols    : T_Ch3;
  69.                 Spacer3  : char;
  70.                 FRows    : T_Ch3;
  71.                 Spacer4  : char;
  72.                 CrcValue : T_Ch5;
  73.                 Spacer5  : char;
  74.                 HexFlag  : char;
  75.                 Spacer6  : T_Ch2;
  76.                 FName    : T_Ch12;
  77.                 Block    : T_Ch3;
  78.                 Spacer7  : T_Ch3;
  79.                 BlockTot : T_Ch3;
  80.                 Spacer8  : T_Ch2;
  81.               end;
  82.  
  83. const
  84.   co_MaxBuffSize = 65520;
  85.  
  86. type
  87.   T_EncBuff    = array[1..co_MaxBuffSize] of char;
  88.   T_EncBuffPtr = ^T_EncBuff;
  89.  
  90.   T_BinBuff    = array[1..((co_MaxBuffSize div 4) * 3)] of byte;
  91.   T_BinBuffPtr = ^T_BinBuff;
  92.  
  93. (******************************** CONSTANTS ***********************************)
  94. const
  95.               (* Column, row default size.                                    *)
  96.   co_ColDef = 72;
  97.   co_RowDef = 85;
  98.  
  99.               (* Minimum and maximum column size.                             *)
  100.   co_MinCol = 60;
  101.   co_MaxCol = 100;
  102.  
  103.               (* Minimum and maximum row size.                                *)
  104.   co_MinRow = 10;
  105.   co_MaxRow = 600;
  106.  
  107.               (* Encoded block maximum.                                       *)
  108.   co_BlockMax = 255;
  109.  
  110.               (* Size of encoded header.                                      *)
  111.   co_HeaderSize  = sizeof(T_Header1);
  112.  
  113.               (* File date constants.                                         *)
  114.   co_ThisCentury = 1900;
  115.   co_NextCentury = 2000;
  116.  
  117.               (* Numeric error constant.                                      *)
  118.   co_NumError    = -1111111111;
  119.  
  120.               (* Maximum encodeable binary file size in bytes.                *)
  121.   co_MaxFilesize = 11455875;
  122.  
  123.               (* Keypress constants.                                          *)
  124.   co_EnterKey     = #13;
  125.   co_BackSpaceKey = #8;
  126.  
  127. (************************* PRE-INITIALIZED VARIABLES **************************)
  128.  
  129.               (* Encoding boolean flag.                                       *)
  130.   bo_Encoding  : boolean = false;
  131.  
  132.               (* Test-mode boolean flag.                                      *)
  133.   bo_TestMode  : boolean = false;
  134.  
  135.               (* Split encoded output flag.                                   *)
  136.   bo_SplitOutput : boolean = false;
  137.  
  138.               (* Erase corrupt output file flag.                              *)
  139.   bo_EraseOutFile : boolean = false;
  140.  
  141.               (* Carriage-return and line-feed constants.                     *)
  142.   co_CrLf      : T_Ch2 = #13#10;
  143.   co_CrLf2     : T_Ch4 = #13#10#13#10;
  144.  
  145.               (* Initial encoded block delimiter.                             *)
  146.   co_XxBlockID : T_Ch7 = '*XX3402';
  147.  
  148.               (* Alternative delimiter character set.                         *)
  149.   co_AltDelSet : array[0..9] of char = '*:#@=$?%&!';
  150.  
  151.               (* Alternative delimiter look-up string.                        *)
  152.   co_AltDelStr : T_Ch27 = 'AD1AD2AD3AD4AD5AD6AD7AD8AD9';
  153.  
  154.               (* Encoded block end marker constants.                          *)
  155.   co_EndMark1  : T_Ch5  = '*****';
  156.  
  157.   co_EndMark2  : T_Ch14 = ' END OF BLOCK ';
  158.  
  159.               (* Encoded block header constant.                               *)
  160.   co_Header1   : T_Header1 =
  161.                           '*XX3402-000000-000000--72--85-00000------------.-------OF---' + #13#10;
  162.  
  163.               (* Standard XX encoding character array.                        *)
  164.   co_XxChar1   : T_Ch64 = '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  165.  
  166.               (* Standard XX encoding character set.                          *)
  167.   co_XxChar2   : set of char = ['+','-','0'..'9','A'..'Z','a'..'z'];
  168.  
  169.               (* Translation table for encoded characters.                    *)
  170.   co_BinTable  : T_By80 = ( 0,  0,  1,  0,  0,  2,  3,  4,  5,  6,
  171.                             7,  8,  9, 10, 11,  0,  0,  0,  0,  0,
  172.                             0,  0, 12, 13, 14, 15, 16, 17, 18, 19,
  173.                            20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
  174.                            30, 31, 32, 33, 34, 35, 36, 37,  0,  0,
  175.                             0,  0,  0,  0, 38, 39, 40, 41, 42, 43,
  176.                            44, 45, 46, 47, 48, 49, 50, 51, 52, 53,
  177.                            54, 55, 56, 57, 58, 59, 60, 61, 62, 63);
  178.  
  179.               (* First parameter look-up string.                              *)
  180.   co_Params1   : T_Ch10 = 'eEdDestTES';
  181.  
  182.               (* Hexidecimal character array.                                 *)
  183.   co_HexChars  : array[0..15] of char = '0123456789ABCDEF';
  184.  
  185.               (* Set of valid DOS filename characters.                        *)
  186.   se_FNameChars : set of char = [#33, #35..#41, #45, '0'..'9', '@'..'Z', '^'..'{', '}', '~'];
  187.  
  188. (********************** END OF GLOBAL DATA DEFINITIONS ************************)
  189.  
  190.  
  191.   (***** Convert BYTE to HEX string.                                          *)
  192.   (*                                                                          *)
  193.   function Byte2Hex({input }
  194.                        by_IN : byte) :
  195.                     {output}
  196.                        T_St2;
  197.   begin
  198.     Byte2Hex[0] := #2;
  199.     Byte2Hex[1] := co_HexChars[(by_IN SHR 4)];
  200.     Byte2Hex[2] := co_HexChars[(by_IN AND $F)]
  201.   end;        (* Byte2Hex.                                                    *)
  202.  
  203.  
  204.   (***** Convert LONGINT to HEX string.                                       *)
  205.   (*                                                                          *)
  206.   function Long2Hex({input }
  207.                        lo_IN : longint) :
  208.                     {output}
  209.                        T_St8;
  210.   var
  211.     by_4 : array[1..4] of byte absolute lo_IN;
  212.   begin
  213.     Long2Hex[0] := #8;
  214.     Long2Hex[1] := co_HexChars[(by_4[4] SHR 4)];
  215.     Long2Hex[2] := co_HexChars[(by_4[4] AND $F)];
  216.     Long2Hex[3] := co_HexChars[(by_4[3] SHR 4)];
  217.     Long2Hex[4] := co_HexChars[(by_4[3] AND $F)];
  218.     Long2Hex[5] := co_HexChars[(by_4[2] SHR 4)];
  219.     Long2Hex[6] := co_HexChars[(by_4[2] AND $F)];
  220.     Long2Hex[7] := co_HexChars[(by_4[1] SHR 4)];
  221.     Long2Hex[8] := co_HexChars[(by_4[1] AND $F)]
  222.   end;        (* Long2Hex.                                                    *)
  223.  
  224.  
  225.   (***** Search data buffer with TP's POS function.                           *)
  226.   (*                                                                          *)
  227.   function PosSearch({input }
  228.                      var Buffer;
  229.                          wo_BuffSize : word;
  230.                          st_Pattern  : string) :
  231.                      {output}
  232.                          word;
  233.   type
  234.     T_Wo2   = array[1..2] of word;
  235.     T_Ch255 = array[1..255] of char;
  236.   var
  237.     po_Buffer   : ^T_Ch255;
  238.     by_Pos,
  239.     by_IncSize,
  240.     by_PredSize : byte;
  241.     wo_Index    : word;
  242.   begin
  243.               (* Initialize variables.                                        *)
  244.     wo_Index := 0;
  245.     po_Buffer := addr(Buffer);
  246.     by_PredSize := pred(length(st_Pattern));
  247.     by_IncSize := (255 - by_PredSize);
  248.  
  249.               (* Repeat..Until "pattern" found, or buffer completely searched *)
  250.     repeat
  251.               (* Search for "pattern" string.                                 *)
  252.       by_Pos := pos(st_Pattern, po_Buffer^);
  253.  
  254.               (* If "pattern" not found, then advance pointer address.        *)
  255.       if (by_Pos = 0) then
  256.         begin
  257.           inc(wo_Index, by_IncSize);
  258.           inc(T_Wo2(po_Buffer)[1], by_IncSize);
  259.  
  260.               (* Normalize pointer.                                           *)
  261.           inc(T_Wo2(po_Buffer)[2], (T_Wo2(po_Buffer)[1] SHR 4));
  262.           T_Wo2(po_Buffer)[1] := (T_Wo2(po_Buffer)[1] MOD $10)
  263.         end
  264.       else
  265.               (* Else "pattern" was found, advance index variable.            *)
  266.         inc(wo_Index, by_Pos)
  267.     until (by_Pos <> 0) OR (wo_Index > wo_BuffSize);
  268.  
  269.               (* If "pattern" not found, then...                              *)
  270.     if (by_Pos = 0) OR (wo_Index > (wo_BuffSize - by_PredSize)) then
  271.       PosSearch := 0
  272.     else
  273.               (* Else "pattern" was found.                                    *)
  274.       PosSearch := wo_Index
  275.   end;        (* PosSearch.                                                   *)
  276.  
  277.  
  278.   (***** Convert a numerical string to a LONGINT.                             *)
  279.   (*                                                                          *)
  280.   function Str2Long({input }
  281.                        st_IN     : T_St20;
  282.                        bo_HexNum : boolean) :
  283.                     {output}
  284.                        longint;
  285.   var
  286.     in_Error : integer;
  287.     lo_Temp  : longint;
  288.   begin
  289.     while (pos('-', st_IN) <> 0) do
  290.       delete(st_IN, pos('-', st_IN), 1);
  291.     if bo_HexNum then
  292.       st_IN := '$' + st_IN;
  293.     val(st_IN, lo_Temp, in_Error);
  294.     if (in_Error <> 0) then
  295.       Str2Long := co_NumError
  296.     else
  297.       Str2Long := lo_Temp
  298.   end;        (* Str2Long.                                                    *)
  299.  
  300.  
  301. const         (* Hexidecimal-mode boolean flag.                               *)
  302.   bo_HexMode : boolean = false;
  303.  
  304.  
  305.   (***** Convert a WORD to numerical character string.                        *)
  306.   (*                                                                          *)
  307.   procedure Word2Char1({input }
  308.                            wo_IN : word;
  309.                        {output}
  310.                        var ch_OUT);
  311.   var
  312.     by_Temp : byte;
  313.     st_Temp : string[6];
  314.   begin
  315.     if bo_HexMode then
  316.       begin
  317.         st_Temp := Byte2Hex(lo(wo_IN));
  318.         by_Temp := 1;
  319.         while (st_Temp[by_Temp] = '0') do
  320.           begin
  321.             delete(st_Temp, by_Temp, 1);
  322.             inc(by_Temp)
  323.           end
  324.       end
  325.     else
  326.       str(wo_IN, st_Temp);
  327.     by_Temp := succ(length(st_Temp));
  328.     fillchar(st_Temp[by_Temp], (sizeof(st_Temp) - by_Temp), #32);
  329.     move(st_Temp[1], ch_OUT, 2)
  330.   end;        (* Word2Char1.                                                  *)
  331.  
  332.  
  333.   (***** Convert a WORD to numerical character string.                        *)
  334.   (*                                                                          *)
  335.   procedure Word2Char2({input }
  336.                           wo_IN : word;
  337.                        {output}
  338.                        var ch_OUT);
  339.   var
  340.     by_Temp : byte;
  341.     st_Temp : string[6];
  342.   begin
  343.     if bo_HexMode then
  344.       begin
  345.         st_Temp := Byte2Hex(lo(wo_IN));
  346.         by_Temp := 1;
  347.         while (st_Temp[by_Temp] = '0') do
  348.           begin
  349.             st_Temp[by_Temp] := '-';
  350.             inc(by_Temp)
  351.           end
  352.       end
  353.     else
  354.       str(wo_IN, st_Temp);
  355.     while (length(st_Temp) < 3) do
  356.       st_Temp := '-' + st_Temp;
  357.     move(st_Temp[1], ch_OUT, 3)
  358.   end;        (* Word2Char2.                                                  *)
  359.  
  360.  
  361.   (***** Convert a LONGINT to a numerical character string.                   *)
  362.   (*                                                                          *)
  363.   procedure Long2Str({input }
  364.                          lo_IN   : longint;
  365.                          by_Size : byte;
  366.                      {update}
  367.                      var Data);
  368.   var
  369.     st_Temp : T_St12;
  370.   begin
  371.     str(lo_IN, st_Temp);
  372.     while (length(st_Temp) < by_Size) do
  373.       st_Temp := '0' + st_Temp;
  374.     move(st_Temp[1], Data, by_Size)
  375.   end;        (* Long2Str.                                                    *)
  376.  
  377.  
  378.   (***** Convert a string to uppercase chars.                                 *)
  379.   (*                                                                          *)
  380.   function UpStr({input }
  381.                     st_IN : string) :
  382.                  {output}
  383.                     string;
  384.   var
  385.     by_Index : byte;
  386.   begin
  387.     for by_Index := 1 to length(st_IN) do
  388.       st_IN[by_Index] := upcase(st_IN[by_Index]);
  389.     UpStr := st_IN
  390.   end;        (* UpStr.                                                       *)
  391.  
  392.  
  393.   (***** Function to indicate if a key-press is in the keyboard buffer.       *)
  394.   (*                                                                          *)
  395.   function KeyPressed : {output}
  396.                            boolean; assembler;
  397.   asm
  398.     mov ah, 01h
  399.     int 16h
  400.     mov ax, 00h
  401.     jz @1
  402.     inc ax
  403.     @1:
  404.   end;        (* KeyPressed.                                                  *)
  405.  
  406.  
  407.   (***** Read a key-press.                                                    *)
  408.   (*                                                                          *)
  409.   function ReadKey: {output}
  410.                        char; assembler;
  411.   asm
  412.     mov ah, 00h
  413.     int 16h
  414.   end;        (* ReadKey.                                                     *)
  415.  
  416.  
  417.   (***** Obtain Yes/No/Rename response from user.                             *)
  418.   (*                                                                          *)
  419.   function YesNoRename : {output}
  420.                             char;
  421.   var
  422.     ch_Key : char;
  423.   begin
  424.     while KeyPressed do
  425.       ch_Key := ReadKey;
  426.     if bo_Encoding then
  427.       repeat
  428.         ch_Key := upcase(ReadKey)
  429.       until(ch_Key in ['N','Y'])
  430.     else
  431.       repeat
  432.         ch_Key := upcase(ReadKey)
  433.       until(ch_Key in ['N','R','Y']);
  434.     writeln(ch_Key);
  435.     YesNoRename := ch_Key
  436.   end;        (* YesNoRename.                                                 *)
  437.  
  438.  
  439.   (***** Obtain a valid filename from end user.                               *)
  440.   (*                                                                          *)
  441.   function EnterFileName : T_St12;
  442.   var
  443.     by_DotPos,
  444.     by_CharIndex : byte;
  445.     bo_EntryOK,
  446.     bo_BackSpace : boolean;
  447.     ch_Key       : char;
  448.     st_Name      : T_St12;
  449.   begin
  450.     by_CharIndex := 1;
  451.     by_DotPos    := 0;
  452.     st_Name      := '';
  453.     repeat
  454.       bo_EntryOK   := false;
  455.       bo_BackSpace := false;
  456.       ch_Key := upcase(readkey);
  457.       if ch_Key IN se_FNameChars then
  458.         bo_EntryOK := true
  459.       else
  460.         case ch_Key of
  461.           '.' : if  (by_CharIndex > 1)
  462.                 and (by_DotPos = 0) then
  463.                   by_CharIndex := 9;
  464.           co_BackSpaceKey : bo_BackSpace := true
  465.         end;
  466.       if  bo_BackSpace
  467.       and (by_CharIndex > 1) then
  468.         begin
  469.           if by_DotPos > 0 then
  470.             dec(by_DotPos);
  471.           if (by_DotPos = 0) then
  472.             by_CharIndex := length(st_Name)
  473.           else
  474.             dec(by_CharIndex);
  475.           dec(st_Name[0]);
  476.           write(co_BackSpaceKey, ' ', co_BackSpaceKey)
  477.         end
  478.       else
  479.         if  (by_CharIndex = 9)
  480.         and (ch_Key <> co_EnterKey) then
  481.           begin
  482.             bo_EntryOK := true;
  483.             ch_Key := '.';
  484.             inc(by_DotPos)
  485.           end;
  486.       if  bo_EntryOK
  487.       and (by_CharIndex < 13) then
  488.         begin
  489.           st_Name := st_Name + ch_Key;
  490.           write(ch_Key);
  491.           if (by_CharIndex > 9) then
  492.             inc(by_DotPos);
  493.           inc(by_CharIndex)
  494.         end
  495.     until (ch_Key = co_EnterKey) and (st_Name <> '');
  496.     EnterFileName := st_Name
  497.   end;        (* EnterFilename.                                               *)
  498.  
  499.  
  500.   (****** Calculate a 16-bit CRC check for the data buffer.                   *)
  501.   (*                                                                          *)
  502.   function CalcCRC16({input }
  503.                      var Data;
  504.                          wo_DataSize : word)
  505.                      {output} :
  506.                          word;
  507.   var
  508.     wo_CRC : word;
  509.   begin
  510.     wo_CRC := 0;
  511.     wo_CRC := UpdateCrc16(wo_CRC, Data, wo_DataSize);
  512.     CalcCRC16 := wo_CRC
  513.   end;        (* CalcCRC16.                                                   *)
  514.  
  515.  
  516.   (***** Display program syntax.                                              *)
  517.   (*                                                                          *)
  518.   procedure Syntax;
  519.   begin
  520.     writeln;
  521.     writeln(' XX3402  Binary Encoder/Decoder  Version 0.2  01-28-94');
  522.     writeln('         Public-Domain Utility by Guy McLoughlin  ');
  523.     writeln;
  524.     writeln('   Usage: XX3402 <E|ES|D|T> [d:][path]<filename> [cols] [rows] [ADn]');
  525.     writeln;
  526.     writeln('   Encode Parameters');
  527.     writeln('        <E> Encode binary file (single output file)');
  528.     writeln('       <ES> Encode binary file (split output files)');
  529.     writeln('     [cols] Min = 60, Max = 100 (default = 72)');
  530.     writeln('     [rows] Min = 10, Max = 600 (default = 85)');
  531.     writeln('      [ADn] Alternative delimiter (n = 1..9)');
  532.     writeln;
  533.     writeln('   Decode Parameters');
  534.     writeln('        <D> Decode encoded file (Halt on any error  )');
  535.     writeln('        <T> Test encoded blocks (Test for CRC errors)');
  536.     writeln;
  537.     writeln('   Examples');
  538.     writeln('     XX3402 E  MYFILE.ZIP (Encode MYFILE.ZIP, using defaults )');
  539.     writeln('     XX3402 ES MYFILE.ZIP (Encode MYFILE.ZIP, split output   )');
  540.     writeln('     XX3402 D  MYFILE.XX  (Decode MYFILE.XX,  using defaults )');
  541.     writeln('     XX3402 T  MYFILE.XX  (Test   MYFILE.XX,  display results)');
  542.     halt(0)
  543.   end;        (* Syntax.                                                      *)
  544.  
  545.  
  546.   (***** Set alternative delimiter.                                           *)
  547.   (*                                                                          *)
  548.   procedure SetAltDel({input}
  549.                          ch_AD : char);
  550.   begin
  551.     co_XxBlockID[1] := ch_AD;
  552.     co_Header1[1] := ch_AD;
  553.     fillchar(co_EndMark1, sizeof(co_EndMark1), ch_AD)
  554.   end;        (* SetAltDel.                                                   *)
  555.  
  556.  
  557. var
  558.   st_DirIN      : dirstr;
  559.   st_NameIN     : namestr;
  560.   st_ExtIN      : extstr;
  561.   wo_EncRowSize : word;
  562.   wo_EncColSize : word;
  563.   co_Header2    : T_Header2 absolute co_Header1;
  564.  
  565.  
  566.   (***** Process the command-line parameters.                                 *)
  567.   (*                                                                          *)
  568.   procedure ProcessParams;
  569.   begin
  570.               (* If too many or too few parameters, then display syntax.      *)
  571.     if (paramcount > 5)
  572.     OR (paramcount < 2) then
  573.       Syntax;
  574.  
  575.               (* Process first parameter.                                     *)
  576.     case pos(paramstr(1), co_Params1) of
  577.        1, 2 : bo_Encoding := true;      (* 'e'  or 'E'                        *)
  578.        3, 4 :;                          (* 'd'  or 'D'                        *)
  579.        7, 8 : bo_TestMode := true;      (* 't'  or 'T'                        *)
  580.        5, 9 : begin                     (* 'es' or 'ES'                       *)
  581.                 bo_Encoding    := true;
  582.                 bo_SplitOutput := true
  583.               end
  584.     else
  585.       Syntax
  586.     end;
  587.               (* Assign the name of the input file.                           *)
  588.     fsplit(fexpand(paramstr(2)), st_DirIN, st_NameIN, st_ExtIN);
  589.  
  590.               (* If we are encoding binary data, then...                      *)
  591.     if bo_Encoding then
  592.       begin
  593.               (* Set encoded column size.                                     *)
  594.         if (paramcount > 2) then
  595.           begin
  596.             wo_EncColSize := Str2Long(paramstr(3), false);
  597.  
  598.               (* Force size to a multiple of 4.                               *)
  599.             wo_EncColSize := (wo_EncColSize SHR 2) SHL 2;
  600.  
  601.               (* If column size is too small or too big, use default size.    *)
  602.             If (wo_EncColSize < co_MinCol)
  603.             OR (wo_EncColSize > co_MaxCol) then
  604.               wo_EncColSize := co_ColDef;
  605.  
  606.               (* Assign column size to the encoded block header.              *)
  607.             Word2Char2(wo_EncColSize, co_Header2.FCols)
  608.           end
  609.         else
  610.           wo_EncColSize := co_ColDef;
  611.  
  612.               (* Set encoded block row size.                                  *)
  613.         if (paramcount > 3) then
  614.           begin
  615.             wo_EncRowSize := Str2Long(paramstr(4), false);
  616.  
  617.               (* If row size is too small or too big, use default size.       *)
  618.             If (wo_EncRowSize < co_MinRow)
  619.             OR (wo_EncRowSize > co_MaxRow) then
  620.               wo_EncRowSize := co_RowDef;
  621.  
  622.               (* Assign row size to the encoded block header.                 *)
  623.             Word2Char2(wo_EncRowSize, co_Header2.FRows)
  624.           end
  625.         else
  626.           wo_EncRowSize := co_RowDef;
  627.  
  628.               (* Set alternative encoded block delimiter.                     *)
  629.         if (paramcount = 5) then
  630.           case pos(UpStr(paramstr(5)), co_AltDelStr) of
  631.            1 : SetAltDel(co_AltDelSet[1]);
  632.            4 : SetAltDel(co_AltDelSet[2]);
  633.            7 : SetAltDel(co_AltDelSet[3]);
  634.           10 : SetAltDel(co_AltDelSet[4]);
  635.           13 : SetAltDel(co_AltDelSet[5]);
  636.           16 : SetAltDel(co_AltDelSet[6]);
  637.           19 : SetAltDel(co_AltDelSet[7]);
  638.           22 : SetAltDel(co_AltDelSet[8]);
  639.           25 : SetAltDel(co_AltDelSet[9]);
  640.         else
  641.           Syntax
  642.         end
  643.       end
  644.   end;        (* ProcessParams.                                               *)
  645.  
  646.  
  647.   (***** Check if a file exists.                                              *)
  648.   (*                                                                          *)
  649.   function FileExist({input}
  650.                         st_Path : pathstr) :
  651.                      {output}
  652.                         boolean;
  653.   begin
  654.     FileExist := (FSearch(st_Path, '') <> '')
  655.   end;        (* FileExist.                                                   *)
  656.  
  657.  
  658.   (***** Close file variable *only* if open.                                  *)
  659.   (*                                                                          *)
  660.   procedure CloseFile({update}
  661.                       var fi_IN);
  662.   begin
  663.     case filerec(fi_IN).mode of
  664.       fminput,
  665.       fmoutput,
  666.       fminout  : close(file(fi_IN))
  667.     end;
  668.     if (ioresult <> 0) then
  669.       halt(1)
  670.   end;        (* CloseFile.                                                   *)
  671.  
  672.  
  673. var
  674.   wo_EncBlockNum : word;
  675.   lo_FileTime    : longint;
  676.   st_NameOUT     : namestr;
  677.   st_ExtOUT      : extstr;
  678.   st_FilenameOUT : T_St12;
  679.   fi_IN          : file;
  680.   fi_OUT         : file;
  681.  
  682.  
  683.   (***** Close all data files.                                                *)
  684.   (*                                                                          *)
  685.   procedure CloseDataFiles;
  686.   begin
  687.               (* Close input file.                                            *)
  688.     CloseFile(fi_IN);
  689.  
  690.               (* If not test-mode, then...                                    *)
  691.     if NOT bo_TestMode then
  692.       begin
  693.               (* If decoding and output file is not corrupt, then...          *)
  694.         if  (NOT bo_Encoding)
  695.         AND (NOT bo_EraseOutFile) then
  696.           begin
  697.  
  698.               (* Set the output file date to the original binary file date.   *)
  699.             setftime(fi_OUT, lo_FileTime);
  700.             if (doserror <> 0) then
  701.               begin
  702.                 writeln(co_CrLf, 'ERROR SETTING DECODED FILE DATE ATTRIBUTE');
  703.                 halt(1)
  704.               end
  705.           end;
  706.  
  707.               (* Close output file.                                           *)
  708.         CloseFile(fi_OUT);
  709.  
  710.               (* If output file is corrupt, then errase it.                   *)
  711.         if bo_EraseOutFile then
  712.           begin
  713.             erase(fi_OUT);
  714.             writeln(co_CrLf, 'OUTPUT FILE (', st_FilenameOUT, ') ERASED');
  715.             halt(1)
  716.           end
  717.       end
  718.   end;         (* CloseDataFiles.                                             *)
  719.  
  720.  
  721. var
  722.   bo_FileSizeFail  : boolean;
  723.   bo_FileDateFail  : boolean;
  724.   bo_BlockSizeFail : boolean;
  725.   bo_FileNameFail  : boolean;
  726.  
  727.  
  728.   (***** Convert byte to block number string.                                 *)
  729.   (*                                                                          *)
  730.   function BlockNumStr({input }
  731.                           by_Block : byte) :
  732.                        {output}
  733.                           T_St2;
  734.   var
  735.     st_Num : T_St2;
  736.   begin
  737.     if bo_HexMode then
  738.       BlockNumStr := Byte2Hex(by_Block)
  739.     else
  740.       begin
  741.         str(by_Block, st_Num);
  742.         BlockNumStr := st_Num
  743.       end
  744.   end;        (* WriteBlockNum                                                *)
  745.  
  746.  
  747.   (***** Display error message.                                               *)
  748.   (*                                                                          *)
  749.   procedure ErrorMsg({input }
  750.                       const st_Path  : pathstr;
  751.                             by_Block : byte;
  752.                             by_Lfeed : byte;
  753.                             in_Error : integer;
  754.                             bo_Halt  : boolean);
  755.   var
  756.     by_Index : byte;
  757.   begin
  758.     for by_Index := 1 to by_Lfeed do
  759.       writeln;
  760.     case in_Error of
  761.         2 : writeln('FILE NOT FOUND ---> ', st_Path);
  762.         4 : writeln('TOO MANY FILES OPEN');
  763.         5 : writeln('FILE ACCESS DENIED ---> ', st_Path);
  764.        15 : writeln('INVALID DRIVE ---> ', st_Path[1] + ':');
  765.       100 : writeln('DISK ', st_Path[1], ': READ ERROR');
  766.       101 : writeln('DISK ', st_Path[1], ': WRITE ERROR');
  767.       150 : writeln('DISK ', st_Path[1], ': IS WRITE PROTECTED');
  768.       152 : writeln('DRIVE ', st_Path[1], ': NOT READY');
  769.       500 : writeln('ZERO BYTE FILE (CONTAINS NO DATA) ---> ', st_Path);
  770.       501 : writeln('FILE IS TOO LARGE TO ENCODE ---> ', st_Path);
  771.       502 : writeln('XX-BLOCK SIZE IS TOO SMALL TO ENCODE ---> ', st_Path);
  772.       503 : writeln('CANNOT OVERWRITE FILE TO ENCODE');
  773.       504 : writeln('NOT ENOUGH FREE MEMORY');
  774.       505 : writeln('XX34 HEADER ID NOT FOUND');
  775.       506 : writeln('INVALID FILE SIZE ---> BLOCK ', BlockNumStr(by_Block));
  776.       507 : writeln('BLOCK NUMBER GREATER THAN BLOCK TOTAL ---> BLOCK ', BlockNumStr(by_Block));
  777.       508 : writeln('XX HEADER FILE SIZES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block));
  778.       509 : writeln('XX HEADER FILE DATES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block));
  779.       510 : writeln('XX HEADER COLUMN/ROW SIZES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block));
  780.       511 : writeln('XX HEADER FILE NAMES DO NOT MATCH ---> BLOCK ', BlockNumStr(by_Block));
  781.       512 : writeln('CANNOT OVERWRITE FILE TO DECODE');
  782.       513 : writeln('OUTPUT FILE IS READ-ONLY ---> ', st_Path);
  783.       514 : writeln('ERROR CONVERTING DATE-STRING TO DATE-RECORD FORMAT');
  784.       515 : writeln('CRC FAILURE ---> BLOCK ', BlockNumStr(by_Block))
  785.     else
  786.       writeln('DOS ERROR = ', in_Error)
  787.     end;
  788.     if bo_Halt then
  789.       begin
  790.         CloseDataFiles;
  791.         halt(1)
  792.       end
  793.   end;        (* ErrorMsg.                                                    *)
  794.  
  795.  
  796. var
  797.   in_Error         : integer;
  798.   wo_EncBlockSize  : word;
  799.   wo_BinBlockSize  : word;
  800.   wo_EncBlockTotal : word;
  801.   lo_FileSizeIN    : longint;
  802.   rc_FileDate      : datetime;
  803.  
  804.  
  805.   (***** Open input and output files.                                         *)
  806.   (*                                                                          *)
  807.   procedure OpenFiles;
  808.   var
  809.     st_Temp : T_St8;
  810.   begin
  811.               (* Check if input file exists.                                  *)
  812.     if FileExist(st_DirIN + st_NameIN + st_ExtIN) then
  813.       assign(fi_IN, (st_DirIN + st_NameIN + st_ExtIN))
  814.     else
  815.       ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 2, true);
  816.  
  817.               (* Set TP's filemode variable to read-only.                     *)
  818.     filemode := 0;
  819.  
  820.               (* Try to open the input file.                                  *)
  821.     reset(fi_IN, 1);
  822.     in_Error := ioresult;
  823.     if (in_Error <> 0) then
  824.       ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true);
  825.  
  826.               (* Record the input file size in bytes.                         *)
  827.     lo_FileSizeIN := filesize(fi_IN);
  828.  
  829.               (* Check if input file is a "zero-byte" file.                   *)
  830.     if (lo_FileSizeIN = 0) then
  831.       ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 500, true);
  832.  
  833.               (* If encoding, then...                                         *)
  834.     if bo_Encoding then
  835.       begin
  836.               (* Check if input file is too big to encode.                    *)
  837.         if (lo_FileSizeIN > co_MaxFileSize) then
  838.           ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 501, true);
  839.  
  840.               (* Calculate encoded block size.                                *)
  841.         wo_EncBlockSize := wo_EncColSize * pred(wo_EncRowSize);
  842.  
  843.               (* Calculate binary block size.                                 *)
  844.         wo_BinBlockSize := (wo_EncBlockSize div 4) * 3;
  845.  
  846.               (* Calculate total number of encoded blocks required.           *)
  847.         wo_EncBlockTotal := (lo_FileSizeIN div wo_BinBlockSize);
  848.         if ((lo_FileSizeIN mod wo_BinBlockSize) <> 0) then
  849.           inc(wo_EncBlockTotal);
  850.  
  851.               (* If encoded block total is equal to one, do not split output. *)
  852.         if (wo_EncBlockTotal = 1) then
  853.           bo_SplitOutput := false;
  854.  
  855.               (* If binary block size is too small to encode the input file.  *)
  856.         if (wo_EncBlockTotal > co_BlockMax) then
  857.           ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, 502, true);
  858.  
  859.               (* Set hex-mode flag if block total is greater than 99, or if   *)
  860.               (* binary file size is greater than 999,999 bytes.              *)
  861.         bo_HexMode := (wo_EncBlockTotal > 99) OR (lo_FileSizeIN > 999999);
  862.  
  863.               (* If hex-mode, then set encoded block header hex-flag.         *)
  864.         if bo_HexMode then
  865.           co_Header2.HexFlag := 'H';
  866.  
  867.               (* Read input file date.                                        *)
  868.         getftime(fi_IN, lo_FileTime);
  869.         in_Error := doserror;
  870.         if (in_Error <> 0) then
  871.           ErrorMsg((st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true);
  872.         unpacktime(lo_FileTime, rc_FileDate);
  873.  
  874.               (* Assign input file date to the encoded header.                *)
  875.         with rc_FileDate do
  876.           begin
  877.             Long2Str(day,   2, co_Header2.Fday);
  878.             Long2Str(month, 2, co_Header2.Fmonth);
  879.             if (year < co_NextCentury) then
  880.               dec(year, co_ThisCentury)
  881.             else
  882.               dec(year, co_NextCentury);
  883.             Long2Str(year,  2, co_Header2.Fyear)
  884.           end;
  885.  
  886.               (* Assign input file size to the encoded header.                *)
  887.         if bo_HexMode then
  888.           begin
  889.             st_Temp := Long2Hex(lo_FileSizeIN);
  890.             delete(st_Temp, 1, 2);
  891.             move(st_Temp[1], co_Header2.Size, 6)
  892.           end
  893.         else
  894.           Long2Str(lo_FileSizeIN, 6, co_Header2.Size);
  895.  
  896.               (* Assign input filename to the encoded header.                 *)
  897.         with co_Header2 do
  898.           begin
  899.             move(st_NameIN[1], Fname[9 - length(st_NameIN)], length(st_NameIN));
  900.             move(st_ExtIN[1],  Fname[9], length(st_ExtIN))
  901.           end;
  902.  
  903.               (* Assign encoded block total to the encoded header.            *)
  904.         Word2Char2(wo_EncBlockTotal, co_Header2.BlockTot);
  905.  
  906.               (* Assign input file name to output file name.                  *)
  907.         st_NameOUT := st_NameIN;
  908.  
  909.               (* Assign output file extension.                                *)
  910.         if bo_SplitOutput then
  911.           st_ExtOUT := '.X01'
  912.         else
  913.           st_ExtOUT  := '.XX';
  914.  
  915.               (* Assign output filename.                                      *)
  916.         assign(fi_OUT, (st_NameOUT + st_ExtOUT));
  917.  
  918.               (* Check if output file already exists.                         *)
  919.         if FileExist(st_NameOUT + st_ExtOUT) then
  920.           begin
  921.  
  922.               (* File exists, is it OK to overwrite this file?                *)
  923.             write(co_CrLf, st_NameOUT + st_ExtOUT, ' already exists. Overwrite? [Y/N] ');
  924.             case YesNoRename of
  925.  
  926.               (* No it's NOT OK to overwrite this file. STOP!                 *)
  927.               'N' : begin
  928.                       writeln(co_CrLf, 'ENCODING ABORTED');
  929.                       CloseDataFiles;
  930.                       halt(0)
  931.                     end;
  932.  
  933.               (* Yes it's OK to overwrite this file.                          *)
  934.               'Y' : begin
  935.  
  936.               (* You cannot overwrite the file you want to encode.            *)
  937.                       if ((st_NameIN + st_ExtIN) = (st_NameOUT + st_ExtOUT)) then
  938.                         ErrorMsg('', 0, 1, 503, true);
  939.  
  940.               (* Rewrite output file.                                         *)
  941.                       rewrite(fi_OUT, 1);
  942.                       in_Error := ioresult;
  943.                       if (in_Error <> 0) then
  944.                         ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true)
  945.                     end
  946.             end
  947.           end
  948.  
  949.               (* Else, the file does not exist.                               *)
  950.         else
  951.           begin
  952.               (* Create the output file.                                      *)
  953.             rewrite(fi_OUT, 1);
  954.             in_Error := ioresult;
  955.             if (in_Error <> 0) then
  956.               ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true)
  957.           end
  958.       end
  959.   end;        (* OpenFiles.                                                   *)
  960.  
  961.  
  962. var
  963.   wo_MaxBlockSize : word;
  964.   wo_EncBuffSize  : word;
  965.   wo_BinBuffSize  : word;
  966.   po_HeapMark     : pointer;
  967.   po_EncBuff      : T_EncBuffPtr;
  968.   po_BinBuff      : T_BinBuffPtr;
  969.  
  970.  
  971.   (***** Create data buffers.                                                 *)
  972.   (*                                                                          *)
  973.   procedure CreateBuffers;
  974.   begin
  975.               (* Determine buffer sizes.                                      *)
  976.     if bo_Encoding then
  977.               (* Encoded block size + size of CrLf's + 128 for header/footer. *)
  978.       wo_MaxBlockSize := wo_EncBlockSize + (wo_EncRowSize SHL 1) + 128;
  979.     wo_EncBuffSize := wo_MaxBlockSize;
  980.     wo_BinBuffSize := (wo_EncBuffSize SHR 2) * 3;
  981.  
  982.               (* Allocate buffers.                                            *)
  983.     mark(po_HeapMark);
  984.     getmem(po_BinBuff, wo_BinBuffSize);
  985.     if (po_BinBuff = NIL) then
  986.       ErrorMsg('', 0, 1, 504, true);
  987.     getmem(po_EncBuff, wo_EncBuffSize);
  988.     if (po_EncBuff = NIL) then
  989.       ErrorMsg('', 0, 1, 504, true)
  990.   end;        (* CreateBuffers.                                               *)
  991.  
  992.  
  993. var
  994.   wo_BytesIN       : word;
  995.   wo_BlockCount    : word;
  996.   wo_EncBuffOffset : word;
  997.   wo_SkipIndex     : word;
  998.  
  999.  
  1000.   (***** Set encoded block header.                                            *)
  1001.   (*                                                                          *)
  1002.   procedure SetEncHeader;
  1003.   begin
  1004.               (* Calculate and set the CRC-16 string for the encoded header.  *)
  1005.     Long2Str(CalcCRC16(po_BinBuff^, wo_BytesIN), 5, co_Header2.CrcValue);
  1006.  
  1007.               (* Set the encoded block's block number.                        *)
  1008.     Word2Char2(wo_BlockCount, co_Header2.Block);
  1009.  
  1010.               (* Write encoded block header to encoding buffer.               *)
  1011.     move(co_CrLf2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf2));
  1012.     inc(wo_EncBuffOffset, sizeof(co_CrLf2));
  1013.     inc(wo_SkipIndex, sizeof(co_CrLf2));
  1014.     move(co_Header2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_Header2));
  1015.  
  1016.               (* Advance the buffer index variables.                          *)
  1017.     inc(wo_EncBuffOffset,  sizeof(co_Header2));
  1018.     inc(wo_SkipIndex, sizeof(co_Header2))
  1019.   end;        (* SetEncHeader.                                                *)
  1020.  
  1021.  
  1022.   (***** Set encoded block footer.                                            *)
  1023.   (*                                                                          *)
  1024.   procedure SetEncFooter;
  1025.   var
  1026.     ar_BlockNum : T_Ch2;
  1027.   begin
  1028.               (* Write encoded block footer to the encoding buffer.           *)
  1029.     move(co_EndMark1, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_EndMark1));
  1030.     inc(wo_EncBuffOffset,  sizeof(co_EndMark1));
  1031.     inc(wo_SkipIndex, sizeof(co_EndMark1));
  1032.     move(co_EndMark2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_EndMark2));
  1033.     inc(wo_EncBuffOffset,  sizeof(co_EndMark2));
  1034.     inc(wo_SkipIndex, sizeof(co_EndMark2));
  1035.     Word2Char1(wo_BlockCount, ar_BlockNum);
  1036.     move(ar_BlockNum, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(ar_BlockNum));
  1037.     inc(wo_EncBuffOffset, sizeof(ar_BlockNum));
  1038.     inc(wo_SkipIndex, sizeof(ar_BlockNum));
  1039.  
  1040.     if bo_HexMode then
  1041.       begin
  1042.         if (po_EncBuff^[wo_EncBuffOffset] = #32) then
  1043.           po_EncBuff^[wo_EncBuffOffset] := 'h'
  1044.         else
  1045.           begin
  1046.             po_EncBuff^[succ(wo_EncBuffOffset)] := 'h';
  1047.             inc(wo_EncBuffOffset);
  1048.             inc(wo_SkipIndex)
  1049.           end
  1050.       end;
  1051.  
  1052.     if (po_EncBuff^[wo_EncBuffOffset] <> #32) then
  1053.       begin
  1054.         po_EncBuff^[succ(wo_EncBuffOffset)] := #32;
  1055.         inc(wo_EncBuffOffset);
  1056.         inc(wo_SkipIndex)
  1057.       end;
  1058.  
  1059.     move(co_EndMark1, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_EndMark1));
  1060.     inc(wo_EncBuffOffset,  sizeof(co_EndMark1));
  1061.     inc(wo_SkipIndex, sizeof(co_EndMark1));
  1062.     move(co_CrLf2, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf2));
  1063.     inc(wo_EncBuffOffset,  sizeof(co_CrLf2));
  1064.     inc(wo_SkipIndex, sizeof(co_CrLf2))
  1065.   end;        (* SetEncFooter.                                                *)
  1066.  
  1067.  
  1068.   (***** Open new output file.                                                *)
  1069.   (*                                                                          *)
  1070.   procedure OpenNewFile;
  1071.   var
  1072.     st_Temp : T_St3;
  1073.   begin
  1074.               (* Close output file.                                           *)
  1075.     close(fi_OUT);
  1076.     in_Error := ioresult;
  1077.     if (in_Error <> 0) then
  1078.       ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true);
  1079.  
  1080.               (* Create new ouput file extension.                             *)
  1081.     st_Temp := BlockNumStr(lo(wo_BlockCount));
  1082.     move(st_Temp[1], st_ExtOUT[5 - length(st_Temp)], length(st_Temp));
  1083.  
  1084.               (* Open new output file.                                        *)
  1085.     assign(fi_OUT, (st_NameOUT + st_ExtOUT));
  1086.     rewrite(fi_OUT, 1);
  1087.     in_Error := ioresult;
  1088.     if (in_Error <> 0) then
  1089.       ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true)
  1090.   end;        (*  OpenNewFile.                                                *)
  1091.  
  1092.  
  1093. var
  1094.   wo_BytesOUT      : word;
  1095.   wo_BinBuffOffset : word;
  1096.  
  1097.  
  1098.   (***** Encode binary file.                                                  *)
  1099.   (*                                                                          *)
  1100.   procedure Encode34;
  1101.   var
  1102.     lo_BytesEncoded : longint;
  1103.   begin
  1104.  
  1105.     CreateBuffers;
  1106.  
  1107.               (* Display encoding message.                                    *)
  1108.     writeln(co_CrLf, 'ENCODING BLOCK');
  1109.  
  1110.               (* Initialize variables.                                        *)
  1111.     wo_BlockCount   := 0;
  1112.     lo_BytesEncoded := 0;
  1113.  
  1114.               (* Repeat until entire binary file has been encoded.            *)
  1115.     repeat
  1116.  
  1117.       wo_SkipIndex     := 0;
  1118.       wo_BinBuffOffset := 0;
  1119.       wo_EncBuffOffset := 0;
  1120.  
  1121.               (* Clear the data buffers.                                      *)
  1122.       fillchar(po_BinBuff^, wo_BinBuffSize, 0);
  1123.       fillchar(po_EncBuff^, wo_EncBuffSize, 0);
  1124.  
  1125.               (* Fill the input buffer.                                       *)
  1126.       blockread(fi_IN, po_BinBuff^, wo_BinBlockSize, wo_BytesIN);
  1127.       in_Error := ioresult;
  1128.       if (in_Error <> 0) then
  1129.         ErrorMsg(fexpand(st_NameIN + st_ExtIN), 0, 1, in_Error, true);
  1130.  
  1131.               (* Ensure the number of bytes to encode is a multiple of 3.     *)
  1132.       if ((wo_BytesIN mod 3) <> 0) then
  1133.         wo_BytesIN := succ(wo_BytesIN div 3) * 3;
  1134.  
  1135.               (* Advance encoded block counter.                               *)
  1136.       inc(wo_BlockCount);
  1137.  
  1138.               (* Display block number being encoded.                          *)
  1139.       write(BlockNumStr(lo(wo_BlockCount)):4);
  1140.  
  1141.               (* Write encoded block header to output buffer.                 *)
  1142.       SetEncHeader;
  1143.  
  1144.       repeat  (* Until all bytes in the input buffer are processed.           *)
  1145.  
  1146.               (* Encode 3 input bytes into 4 encoded XX output characters.    *)
  1147.         po_EncBuff^[succ(wo_EncBuffOffset)] :=
  1148.                                           co_XxChar1[(po_BinBuff^[succ(wo_BinBuffOffset)] SHR 2)];
  1149.  
  1150.         po_EncBuff^[wo_EncBuffOffset + 2] :=
  1151.                   co_XxChar1[((po_BinBuff^[succ(wo_BinBuffOffset)] AND 3) SHL 4)
  1152.                                                     OR (po_BinBuff^[wo_BinBuffOffset + 2] SHR 4)];
  1153.  
  1154.         po_EncBuff^[wo_EncBuffOffset + 3] :=
  1155.                    co_XxChar1[((po_BinBuff^[wo_BinBuffOffset + 2] AND 15) SHL 2)
  1156.                                                     OR (po_BinBuff^[wo_BinBuffOffset + 3] SHR 6)];
  1157.  
  1158.         po_EncBuff^[wo_EncBuffOffset + 4] :=
  1159.                          co_XxChar1[(po_BinBuff^[wo_BinBuffOffset + 3] AND 63)];
  1160.  
  1161.               (* Advance the buffer indexes.                                  *)
  1162.         inc(wo_BinBuffOffset, 3);
  1163.         inc(wo_EncBuffOffset, 4);
  1164.  
  1165.               (* If encoded character row is complete, then...                *)
  1166.         if (((wo_EncBuffOffset - wo_SkipIndex) mod wo_EncColSize) = 0) then
  1167.           begin
  1168.  
  1169.               (* Add a CrLf to the encoded buffer.                            *)
  1170.             move(co_CrLf, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf));
  1171.  
  1172.               (* Advance the buffer indexes.                                  *)
  1173.             inc(wo_EncBuffOffset, sizeof(co_CrLf));
  1174.             inc(wo_SkipIndex, sizeof(co_CrLf))
  1175.           end
  1176.  
  1177.               (* Until all bytes in the input buffer are processed.           *)
  1178.       until (wo_BinBuffOffset >= wo_BytesIN);
  1179.  
  1180.               (* If the last line of encoded output is not complete,then...   *)
  1181.       if (((wo_EncBuffOffset - wo_SkipIndex) mod wo_EncColSize) <> 0) then
  1182.         begin
  1183.               (* Add a CrLf to the encoding buffer.                           *)
  1184.           move(co_CrLf, po_EncBuff^[succ(wo_EncBuffOffset)], sizeof(co_CrLf));
  1185.  
  1186.               (* Advance the buffer indexes.                                  *)
  1187.           inc(wo_EncBuffOffset, sizeof(co_CrLf));
  1188.           inc(wo_SkipIndex, sizeof(co_CrLf))
  1189.         end;
  1190.  
  1191.               (* Write encoded block footer to the output buffer.             *)
  1192.       SetEncFooter;
  1193.  
  1194.               (* If encoded output is split, then...                          *)
  1195.       if  bo_SplitOutput
  1196.       AND (wo_BlockCount > 1) then
  1197.         OpenNewFile;
  1198.  
  1199.               (* Write encoded buffer to output file.                         *)
  1200.       blockwrite(fi_OUT, po_EncBuff^, wo_EncBuffOffset, wo_BytesOUT);
  1201.       in_Error := ioresult;
  1202.       if (in_Error <> 0) then
  1203.         ErrorMsg(fexpand(st_NameOUT + st_ExtOUT), 0, 1, in_Error, true);
  1204.       inc(lo_BytesEncoded, wo_BinBuffOffset)
  1205.     until (lo_BytesEncoded >= lo_FileSizeIN);
  1206.  
  1207.               (* Release heap memory used.                                    *)
  1208.     release(po_HeapMark);
  1209.     writeln
  1210.   end;        (* Encode34.                                                    *)
  1211.  
  1212.  
  1213. var
  1214.   wo_ScanPos : word;
  1215.  
  1216.  
  1217.   (***** Scan input file for encoded block identifier.                        *)
  1218.   (*                                                                          *)
  1219.   procedure ScanForXxID;
  1220.   var
  1221.     wo_Index : word;
  1222.   begin
  1223.               (* Display scanning message.                                    *)
  1224.     write(co_CrLf, 'SCANNING FOR BLOCK IDENTIFIER');
  1225.  
  1226.               (* Calculate buffer size.                                       *)
  1227.     if (lo_FileSizeIN < (60 * 1024)) then
  1228.       wo_EncBuffSize := lo_FileSizeIN
  1229.     else
  1230.       wo_EncBuffSize := 60 * 1024;
  1231.  
  1232.               (* Create scan buffer.                                          *)
  1233.     mark(po_HeapMark);
  1234.     getmem(po_EncBuff, wo_EncBuffSize);
  1235.     if (po_EncBuff = NIL) then
  1236.       ErrorMsg('', 0, 2, 504, true);
  1237.  
  1238.               (* Clear scan buffer.                                           *)
  1239.     fillchar(po_EncBuff^, wo_EncBuffSize, 0);
  1240.  
  1241.               (* Load the scan buffer.                                        *)
  1242.     blockread(fi_IN, po_EncBuff^, wo_EncBuffSize, wo_BytesIN);
  1243.     in_Error := ioresult;
  1244.     if (in_Error <> 0) then
  1245.       ErrorMsg(fexpand(st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true);
  1246.  
  1247.               (* Search for encoded block ID.                                 *)
  1248.     wo_Index := 1;
  1249.     repeat
  1250.       wo_ScanPos := PosSearch(po_EncBuff^, wo_EncBuffSize, co_XxBlockID);
  1251.  
  1252.               (* If encoded block ID was not found, then...                   *)
  1253.       if (wo_ScanPos = 0) then
  1254.         begin
  1255.  
  1256.               (* If all 10 ID delimiters were tried, and version number = '2' *)
  1257.           if  (wo_Index = 10)
  1258.           AND (co_XxBlockID[7] = '2') then
  1259.             begin
  1260.  
  1261.               (* Set version number to '1'.                                   *)
  1262.               co_XxBlockID[7] := '1';
  1263.  
  1264.               (* Reset loop variable.                                         *)
  1265.               wo_Index := 0
  1266.             end;
  1267.  
  1268.               (* Set new block ID delimiter.                                  *)
  1269.           if (wo_Index < 10) then
  1270.             co_XxBlockID[1] := co_AltDelSet[wo_Index];
  1271.  
  1272.               (* Advance loop variable.                                       *)
  1273.           inc(wo_Index)
  1274.         end
  1275.     until (wo_ScanPos <> 0) OR (wo_Index = 11);
  1276.  
  1277.               (* If block ID was not found, then...                           *)
  1278.     if (wo_ScanPos = 0) then
  1279.       begin
  1280.         writeln;
  1281.         ErrorMsg('', 0, 1, 505, true)
  1282.       end
  1283.     else
  1284.       writeln('  OK')
  1285.   end;        (* ScanForXxID.                                                 *)
  1286.  
  1287.  
  1288. var
  1289.   lo_EncFileOffset  : longint;
  1290.   lo_FileSizeOUT    : longint;
  1291.   ar_BinFileDate    : T_3Ch2;
  1292.   ar_Crc16          : T_Wo255;
  1293.   ar_EncBlockFound  : T_By256;
  1294.   ar_EncBlockPos    : T_Lo255;
  1295.   ar_BinBlockSize   : T_Wo255;
  1296.   ar_PhysBlockSize  : T_Lo255;
  1297.  
  1298.  
  1299.   (***** Scan for all encoded block headers.                                  *)
  1300.   (*                                                                          *)
  1301.   procedure ScanForXxHeaders;
  1302.   var
  1303.     wo_Index,
  1304.     wo_TempColSize,
  1305.     wo_TempRowSize,
  1306.     wo_TempBlockNum,
  1307.     wo_TempBlockSize,
  1308.     wo_TempBlockTotal : word;
  1309.     lo_Temp,
  1310.     lo_TempFileSize   : longint;
  1311.     ar_TempFileDate   : T_3Ch2;
  1312.     st_TempOutName    : T_St12;
  1313.   begin
  1314.               (* Display new message.                                         *)
  1315.     write('SCANNING FOR BLOCK HEADERS');
  1316.     bo_FileSizeFail  := false;
  1317.     bo_FileDateFail  := false;
  1318.     bo_BlockSizeFail := false;
  1319.     bo_FileNameFail  := false;
  1320.     wo_EncBuffOffset := 0;
  1321.     wo_BlockCount    := 0;
  1322.     lo_EncFileOffset := 0;
  1323.     fillchar(ar_EncBlockFound, sizeof(ar_EncBlockFound), 0);
  1324.     fillchar(ar_Crc16, sizeof(ar_Crc16), 0);
  1325.     fillchar(ar_EncBlockPos, sizeof(ar_EncBlockPos), 0);
  1326.     fillchar(ar_BinBlockSize, sizeof(ar_BinBlockSize), 0);
  1327.     fillchar(ar_PhysBlockSize, sizeof(ar_PhysBlockSize), 0);
  1328.  
  1329.               (* Repeat until the entire input file has been scanned.         *)
  1330.     repeat
  1331.               (* Determine XX34 header position in the encoded buffer.        *)
  1332.       wo_ScanPos := PosSearch(po_EncBuff^[succ(wo_EncBuffOffset)],
  1333.                                  (wo_BytesIN - (wo_EncBuffOffset + co_HeaderSize)), co_XxBlockID);
  1334.  
  1335.               (* If an encoded header was found, then...                      *)
  1336.       if (wo_ScanPos <> 0) then
  1337.         begin
  1338.               (* Record encoded header position, and advance block count.     *)
  1339.           inc(wo_EncBuffOffset, wo_ScanPos);
  1340.           inc(wo_BlockCount);
  1341.  
  1342.               (* Clear the initialed encoded header variable.                 *)
  1343.           fillchar(co_Header1, sizeof(co_Header1), 0);
  1344.  
  1345.               (* Copy the encoded header found to the header variable.        *)
  1346.           move(po_EncBuff^[wo_EncBuffOffset], co_Header1, sizeof(co_Header1));
  1347.  
  1348.               (* Process encoded header data.                                 *)
  1349.           with co_Header2 do
  1350.             begin
  1351.               bo_HexMode := (HexFlag = 'H');
  1352.  
  1353.               lo_TempFileSize := Str2Long(Size, bo_HexMode);
  1354.  
  1355.               if (lo_TempFileSize = co_NumError)
  1356.               or (lo_TempFileSize < 1) then
  1357.                 ErrorMsg('', lo(wo_BlockCount), 2, 506, true);
  1358.  
  1359.               ar_TempFileDate[1] := Fday;
  1360.               ar_TempFileDate[2] := Fmonth;
  1361.               ar_TempFileDate[3] := Fyear;
  1362.  
  1363.               wo_TempColSize := Str2Long(FCols, false);
  1364.               wo_TempRowSize := Str2Long(FRows, false);
  1365.  
  1366.               st_TempOutName := Fname;
  1367.  
  1368.               wo_TempBlockNum   := Str2Long(Block,    bo_HexMode);
  1369.               wo_TempBlockTotal := Str2Long(BlockTot, bo_HexMode);
  1370.  
  1371.               ar_Crc16[wo_TempBlockNum] := Str2Long(CrcValue, false)
  1372.             end;
  1373.  
  1374.               (* Check if block number from the encoded header is valid.      *)
  1375.           if (wo_TempBlockNum > wo_TempBlockTotal) then
  1376.             ErrorMsg('', lo(wo_BlockCount), 2, 507, true);
  1377.  
  1378.               (* Record encoded block number found.                           *)
  1379.           inc(ar_EncBlockFound[wo_TempBlockNum]);
  1380.  
  1381.               (* Assign the encoded block file position.                      *)
  1382.           if (ar_EncBlockPos[wo_TempBlockNum] = 0) then
  1383.             inc(ar_EncBlockPos[wo_TempBlockNum], wo_EncBuffOffset);
  1384.           if (lo_EncFileOffset <> 0) then
  1385.             inc(ar_EncBlockPos[wo_TempBlockNum], lo_EncFileOffset);
  1386.  
  1387.               (* Calculate temp encoded block size.                           *)
  1388.           wo_TempBlockSize := pred(wo_TempRowSize) * (wo_TempColSize + 2);
  1389.  
  1390.               (* Record temp encoded block size.                              *)
  1391.           ar_BinBlockSize[wo_TempBlockNum] :=
  1392.                                             (((wo_TempColSize * pred(wo_TempRowSize)) SHR 2) * 3);
  1393.  
  1394.               (* If this is physically the first encoded block, record the    *)
  1395.               (* encoded block values.                                        *)
  1396.           if (wo_BlockCount = 1 ) then
  1397.             begin
  1398.               lo_FileSizeOUT   := lo_TempFileSize;
  1399.               ar_BinFileDate   := ar_TempFileDate;
  1400.               wo_EncRowSize    := wo_TempRowSize;
  1401.               wo_EncBlockSize  := wo_TempBlockSize;
  1402.               st_FilenameOUT   := st_TempOutName;
  1403.               wo_EncBlockTotal := wo_TempBlockTotal
  1404.             end
  1405.  
  1406.               (* Else, this is not the first block found, check for errors.   *)
  1407.           else
  1408.             begin
  1409.               if (lo_TempFileSize <> lo_FileSizeOUT)
  1410.               AND (bo_FileSizeFail = false) then
  1411.                 byte(bo_FileSizeFail) := wo_TempBlockNum;
  1412.  
  1413.               if  (T_Ch6(ar_TempFileDate) <> T_Ch6(ar_BinFileDate))
  1414.               AND (bo_FileDateFail = false) then
  1415.                 byte(bo_FileDateFail) := wo_TempBlockNum;
  1416.  
  1417.               if  (wo_TempBlockSize <> wo_EncBlockSize)
  1418.               AND (bo_BlockSizeFail = false) then
  1419.                 byte(bo_BlockSizeFail) := wo_TempBlockNum;
  1420.  
  1421.               If (st_TempOutName <> st_FilenameOUT)
  1422.               AND (bo_FileNameFail = false) then
  1423.                 byte(bo_FileNameFail) := wo_TempBlockNum
  1424.             end;
  1425.  
  1426.               (* Advance the encoded buffer index.                            *)
  1427.           if (wo_EncBuffOffset < (wo_BytesIN - co_HeaderSize)) then
  1428.             inc(wo_EncBuffOffset, co_HeaderSize)
  1429.         end
  1430.  
  1431.               (* Else, no additional encoded headers were found.              *)
  1432.       else
  1433.         begin
  1434.               (* Advance the input file offset.                               *)
  1435.           inc(lo_EncFileOffset, (wo_BytesIN - co_HeaderSize));
  1436.  
  1437.               (* If input file not completely scanned, then reload buffer.    *)
  1438.           if ((lo_EncFileOffset + co_HeaderSize) < lo_FileSizeIN) then
  1439.             begin
  1440.  
  1441.               (* Reset control variables.                                     *)
  1442.               wo_EncBuffOffset := 0;
  1443.  
  1444.               (* Clear scan buffer.                                           *)
  1445.               fillchar(po_EncBuff^, wo_EncBuffSize, 0);
  1446.  
  1447.               (* Reset input file pointer.                                    *)
  1448.               seek(fi_IN, lo_EncFileOffset);
  1449.               in_Error := ioresult;
  1450.               if (in_Error <> 0) then
  1451.                 ErrorMsg(fexpand(st_NameIN + st_ExtIN), 0, 1, in_Error, true);
  1452.  
  1453.               (* Load the scan buffer.                                        *)
  1454.               blockread(fi_IN, po_EncBuff^, wo_EncBuffSize, wo_BytesIN);
  1455.               in_Error := ioresult;
  1456.               if (in_Error <> 0) then
  1457.                 ErrorMsg(fexpand(st_NameIN + st_ExtIN), 0, 1, in_Error, true)
  1458.             end
  1459.         end
  1460.               (* Until the entire input file has been scanned.                *)
  1461.     until (lo_EncFileOffset + co_HeaderSize) > pred(lo_FileSizeIN);
  1462.  
  1463.               (* Release heap memory used.                                    *)
  1464.     release(po_HeapMark);
  1465.     writeln('     OK');
  1466.  
  1467.               (* Encoded block size + 2x CrLF size + 128 for header/footer.   *)
  1468.     wo_MaxBlockSize := wo_EncBlockSize + (wo_EncRowSize SHL 2) + 128;
  1469.  
  1470.               (* Set the maximum physical size for encoded blocks.            *)
  1471.     for wo_Index := 1 to wo_EncBlockTotal do
  1472.       if (ar_EncBlockFound[wo_Index] = 1) then
  1473.         ar_PhysBlockSize[wo_Index] := wo_MaxBlockSize;
  1474.  
  1475.               (* Calculate binary size of last encoded block.                 *)
  1476.     wo_Index := 1;
  1477.     while (ar_EncBlockFound[wo_Index] <> 1)
  1478.     and   (wo_Index < wo_EncBlockTotal) do
  1479.       inc(wo_Index);
  1480.     lo_Temp := lo_FileSizeOUT - (longint(ar_BinBlockSize[wo_Index]) * pred(wo_EncBlockTotal));
  1481.     if (lo_Temp < ar_BinBlockSize[wo_Index]) then
  1482.       begin
  1483.         ar_BinBlockSize[wo_EncBlockTotal]  := lo_Temp;
  1484.         ar_PhysBlockSize[wo_EncBlockTotal] := ((lo_Temp div 3) SHL 2) + (wo_EncRowSize SHL 2)
  1485.       end
  1486.   end;        (* ScanForXxHeaders.                                            *)
  1487.  
  1488.  
  1489.   (***** Check for encoded block errors.                                      *)
  1490.   (*                                                                          *)
  1491.   procedure CheckForXxErrors;
  1492.   var
  1493.     wo_Index : word;
  1494.   begin
  1495.               (* Display error checking message.                              *)
  1496.     write('CHECKING FOR BLOCK ERRORS');
  1497.  
  1498.               (* Check for encoded block data errors.                         *)
  1499.     if bo_FileSizeFail then
  1500.       ErrorMsg('', byte(bo_FileSizeFail),  2, 508, true);
  1501.  
  1502.     if bo_FileDateFail then
  1503.       ErrorMsg('', byte(bo_FileDateFail),  2, 509, true);
  1504.  
  1505.     if bo_BlockSizeFail then
  1506.       ErrorMsg('', byte(bo_BlockSizeFail), 2, 510, true);
  1507.  
  1508.     if bo_FileNameFail then
  1509.       ErrorMsg('', byte(bo_FileNameFail),  2, 511, true);
  1510.  
  1511.               (* Check for duplicate/missing encoded blocks.                  *)
  1512.     for wo_Index := 1 to wo_EncBlockTotal do
  1513.       if (ar_EncBlockFound[wo_Index] <> 1) then
  1514.         inc(ar_EncBlockFound[0]);
  1515.  
  1516.               (* If a duplicate/missing encoded block found, then...          *)
  1517.     if (ar_EncBlockFound[0] <> 0) then
  1518.       begin
  1519.         writeln('     FAIL');
  1520.         writeln;
  1521.         for wo_Index := 1 to wo_EncBlockTotal do
  1522.           if (ar_EncBlockFound[wo_Index] > 1) then
  1523.             writeln('DUPLICATE BLOCK ', BlockNumStr(lo(wo_Index)))
  1524.           else
  1525.             if (ar_EncBlockFound[wo_Index] = 0) then
  1526.               writeln('  MISSING BLOCK ', BlockNumStr(lo(wo_Index)));
  1527.         if NOT bo_TestMode then
  1528.           begin
  1529.             CloseDataFiles;
  1530.             halt(1)
  1531.           end
  1532.       end
  1533.     else
  1534.       writeln('      OK')
  1535.   end;        (* CheckForXxErrors.                                            *)
  1536.  
  1537.  
  1538.   (***** Remove '-' chars from filename.                                      *)
  1539.   (*                                                                          *)
  1540.   procedure CleanFileName;
  1541.   begin
  1542.     while (st_FilenameOUT[1] = '-') do
  1543.       delete(st_FilenameOUT, 1, 1);
  1544.     while (st_FilenameOUT[length(st_FilenameOUT)] = '-') do
  1545.       delete(st_FilenameOUT, length(st_FilenameOUT), 1)
  1546.   end;        (* CleanFileName.                                               *)
  1547.  
  1548.  
  1549.   (***** Prepare the output file for the decoded binary data.                 *)
  1550.   (*                                                                          *)
  1551.   procedure CheckOutputFile;
  1552.   label
  1553.     CheckAgain;
  1554.   var
  1555.     wo_FileAttr : word;
  1556.   begin
  1557.               (* Assign the output file name.                                 *)
  1558.     assign(fi_OUT, st_FilenameOUT);
  1559.  
  1560.               (* Check if binary output file already exists.                  *)
  1561.     if FileExist(st_FilenameOUT) then
  1562.       begin
  1563.  
  1564.   CheckAgain:
  1565.  
  1566.               (* Check to see if it's OK to over-write this file.             *)
  1567.         write(co_CrLf, st_FilenameOUT,' already exists. Overwrite? [Y/N/R] ');
  1568.         case YesNoRename of
  1569.  
  1570.               (* NO it's NOT OK to overwrite this file. STOP!                 *)
  1571.           'N' : begin
  1572.                   writeln(co_CrLf, 'DECODING ABORTED');
  1573.                   CloseDataFiles;
  1574.                   halt(0)
  1575.                 end;
  1576.  
  1577.               (* Rename output filename.                                      *)
  1578.           'R' : begin
  1579.                   write('New output name? ');
  1580.                   st_FilenameOUT := EnterFilename;
  1581.                   writeln;
  1582.  
  1583.               (* If new name exists too, then start over.                     *)
  1584.                   if FileExist(st_FilenameOUT) then
  1585.                     goto CheckAgain;
  1586.  
  1587.               (* Create new output file.                                      *)
  1588.                   assign(fi_Out, st_FilenameOUT);
  1589.                   rewrite(fi_OUT, 1);
  1590.                   in_Error := ioresult;
  1591.                   if (in_Error <> 0) then
  1592.                     ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true)
  1593.                 end;
  1594.  
  1595.               (* Yes it's OK to overwrite file.                               *)
  1596.           'Y' : begin
  1597.  
  1598.               (* You cannot overwrite the file you want to decode.            *)
  1599.                   if ((st_NameIN + st_ExtIN) = st_FilenameOUT) then
  1600.                     ErrorMsg('', 0, 1, 512, true);
  1601.  
  1602.               (* Check to see if the output file is 'READ-ONLY'.              *)
  1603.                   getfattr(fi_OUT, wo_FileAttr);
  1604.                   in_Error := doserror;
  1605.                   if (in_Error <> 0) then
  1606.                     ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true);
  1607.                   if ((wo_FileAttr AND 1) <> 0) then
  1608.                     ErrorMsg(fexpand(st_FilenameOUT), 0, 1, 513, true);
  1609.  
  1610.               (* Create new output file.                                      *)
  1611.                   rewrite(fi_OUT, 1);
  1612.                   in_Error := ioresult;
  1613.                   if (in_Error <> 0) then
  1614.                     ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true)
  1615.                 end
  1616.         end
  1617.       end
  1618.               (* Else the file does not exist, create it.                     *)
  1619.     else
  1620.       begin
  1621.         rewrite(fi_OUT, 1);
  1622.         in_Error := ioresult;
  1623.         if (in_Error <> 0) then
  1624.           ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true)
  1625.       end
  1626.   end;        (* CheckOutputFile.                                             *)
  1627.  
  1628.  
  1629.   (***** Set the file date for the output file.                               *)
  1630.   (*                                                                          *)
  1631.   procedure PrepareFileDate;
  1632.   var
  1633.     in_Error : integer;
  1634.   begin
  1635.               (* Determine original binary file date from XxHeader            *)
  1636.     with rc_FileDate do
  1637.       begin
  1638.         val(ar_BinFileDate[3], year, in_Error);
  1639.         if (in_Error <> 0) then
  1640.           ErrorMsg('', 0, 1, 514, true);
  1641.         inc(year, co_ThisCentury);
  1642.         val(ar_BinFileDate[2], month, in_Error);
  1643.         if (in_Error <> 0) then
  1644.           ErrorMsg('', 0, 1, 514, true);
  1645.         val(ar_BinFileDate[1], day, in_Error);
  1646.         if (in_Error <> 0) then
  1647.           ErrorMsg('', 0, 1, 514, true);
  1648.         hour := 0;
  1649.         min  := 0;
  1650.         sec  := 0
  1651.       end;
  1652.     packtime(rc_FileDate, lo_FileTime)
  1653.   end;        (* PrepareFileDate.                                             *)
  1654.  
  1655.  
  1656.   (***** Decode/Test the encoded input file.                                  *)
  1657.   (*                                                                          *)
  1658.   procedure Decode43;
  1659.   var
  1660.     lo_BytesDecoded : longint;
  1661.   begin
  1662.  
  1663.     ScanForXxID;
  1664.  
  1665.     ScanForXxHeaders;
  1666.  
  1667.     CheckForXxErrors;
  1668.  
  1669.     if NOT bo_TestMode then
  1670.       begin
  1671.         CleanFileName;
  1672.         CheckOutputFile;
  1673.         PrepareFileDate
  1674.       end;
  1675.  
  1676.               (* Display testing/decoding message.                            *)
  1677.     if bo_TestMode then
  1678.       writeln(co_CrLf, 'TESTING BLOCK')
  1679.     else
  1680.       writeln(co_CrLf, 'DECODING BLOCK');
  1681.  
  1682.               (* Initialize variables.                                        *)
  1683.     wo_BytesOUT      := 0;
  1684.     wo_EncBlockNum   := 0;
  1685.     lo_BytesDecoded  := 0;
  1686.     lo_EncFileOffset := 0;
  1687.  
  1688.     CreateBuffers;
  1689.  
  1690.     repeat    (* Until the original binary file has been completely re-built. *)
  1691.  
  1692.               (* Advance the encoded block number to read into the buffer.    *)
  1693.       inc(wo_EncBlockNum);
  1694.  
  1695.               (* Advance the block number until an encoded block is found,    *)
  1696.               (* and block number is less than the encoded the block total.   *)
  1697.       while (ar_EncBlockFound[wo_EncBlockNum] <> 1)
  1698.       and   (wo_EncBlockNum < wo_EncBlockTotal) do
  1699.         inc(wo_EncBlockNum);
  1700.  
  1701.               (* If a valid block exists, then...                             *)
  1702.       if (ar_EncBlockFound[wo_EncBlockNum] = 1) then
  1703.         begin
  1704.               (* Initialize the buffer variables.                             *)
  1705.           wo_BinBuffOffset := 0;
  1706.           wo_EncBuffOffset := co_HeaderSize;
  1707.  
  1708.               (* Clear binary buffer.                                         *)
  1709.           fillchar(po_BinBuff^, wo_BinBuffSize, 0);
  1710.  
  1711.               (* Clear encoded buffer.                                        *)
  1712.           fillchar(po_EncBuff^, wo_EncBuffSize, 0);
  1713.  
  1714.               (* Position input file pointer.                                 *)
  1715.           seek(fi_IN, pred(ar_EncBlockPos[wo_EncBlockNum]));
  1716.           in_Error := ioresult;
  1717.           if (in_Error <> 0) then
  1718.             ErrorMsg(fexpand(st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true);
  1719.  
  1720.               (* Load encoded block into buffer.                              *)
  1721.           blockread(fi_IN, po_EncBuff^, ar_PhysBlockSize[wo_EncBlockNum], wo_BytesIN);
  1722.           in_Error := ioresult;
  1723.           if (in_Error <> 0) then
  1724.             ErrorMsg(fexpand(st_DirIN + st_NameIN + st_ExtIN), 0, 1, in_Error, true);
  1725.  
  1726.               (* Display encoded block number.                                *)
  1727.           write(BlockNumStr(lo(wo_EncBlockNum)):4);
  1728.  
  1729.               (* Until entire encoded block is decoded.                       *)
  1730.           repeat
  1731.  
  1732.               (* Advance encoded buffer offset, while character is not in the *)
  1733.               (* XX character set.                                            *)
  1734.             while NOT (po_EncBuff^[succ(wo_EncBuffOffset)] IN co_XxChar2) do
  1735.               inc(wo_EncBuffOffset);
  1736.  
  1737.               (* Decode 4 encoded chars into 3 binary bytes.                  *)
  1738.             po_BinBuff^[succ(wo_BinBuffOffset)] :=
  1739.                                      (co_BinTable[ord(po_EncBuff^[succ(wo_EncBuffOffset)])] SHL 2)
  1740.                                  OR (co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 2)])] SHR 4);
  1741.  
  1742.             po_BinBuff^[wo_BinBuffOffset + 2] :=
  1743.                             ((co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 2)])] AND 15) SHL 4)
  1744.                                  OR (co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 3)])] SHR 2);
  1745.  
  1746.             po_BinBuff^[wo_BinBuffOffset + 3] :=
  1747.                              ((co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 3)])] AND 3) SHL 6)
  1748.                                 OR (co_BinTable[ord(po_EncBuff^[(wo_EncBuffOffset + 4)])] AND 63);
  1749.  
  1750.               (* Advance buffer indexes.                                      *)
  1751.             inc(wo_EncBuffOffset, 4);
  1752.             inc(wo_BinBuffOffset, 3)
  1753.  
  1754.               (* Until encoded block is completely decoded.                   *)
  1755.           until (wo_BinBuffOffset > pred(ar_BinBlockSize[wo_EncBlockNum]));
  1756.  
  1757.               (* Compare new CRC value with encoded block header CRC value.   *)
  1758.           if (CalcCRC16(po_BinBuff^, wo_BinBuffOffset) <> ar_Crc16[wo_EncBlockNum]) then
  1759.             begin
  1760.               if NOT bo_TestMode then
  1761.                 begin
  1762.                   bo_EraseOutFile := true;
  1763.                   ErrorMsg('', lo(wo_EncBlockNum), 2, 515, true)
  1764.                 end
  1765.               else
  1766.                 writeln(' CRC FAILED')
  1767.             end
  1768.           else
  1769.             if bo_TestMode then
  1770.               writeln(' CRC OK');
  1771.  
  1772.               (* Write the decoded binary bytes to disk.                      *)
  1773.           if NOT bo_TestMode then
  1774.             begin
  1775.               blockwrite(fi_OUT, po_BinBuff^, ar_BinBlockSize[wo_EncBlockNum], wo_BytesOUT);
  1776.               in_Error := ioresult;
  1777.               if (in_Error <> 0) then
  1778.                 ErrorMsg(fexpand(st_FilenameOUT), 0, 1, in_Error, true);
  1779.  
  1780.               (* Advance the binary bytes decoded count.                      *)
  1781.               inc(lo_BytesDecoded, wo_BytesOUT)
  1782.             end
  1783.         end;
  1784.  
  1785.               (* If in "test mode", and last encoded block has been tested,   *)
  1786.               (* then break repeat until loop.                                *)
  1787.       if bo_TestMode AND (wo_EncBlockNum = wo_EncBlockTotal) then
  1788.         break
  1789.  
  1790.               (* Until original binary file has been rebuilt.                 *)
  1791.     until (lo_BytesDecoded > pred(lo_FileSizeOUT));
  1792.  
  1793.               (* Return buffer memory to the heap.                            *)
  1794.     release(po_HeapMark);
  1795.  
  1796.     if NOT bo_TestMode then
  1797.       writeln
  1798.   end;        (* Decode43.                                                    *)
  1799.  
  1800.  
  1801.   (***** Custom heap error function. Returns NIL pointer if error occurs.     *)
  1802.   (*                                                                          *)
  1803.   function CustHeapError({input}
  1804.                             wo_Size : word) :
  1805.                          {output}
  1806.                             integer; far;
  1807.   begin
  1808.     CustHeapError := 1
  1809.   end;        (* CustHeapError.                                               *)
  1810.  
  1811.  
  1812. BEGIN
  1813.               (* Install custom heap error function.                          *)
  1814.   HeapError := addr(CustHeapError);
  1815.  
  1816.   ProcessParams;
  1817.   OpenFiles;
  1818.   if bo_Encoding then
  1819.     Encode34
  1820.   else
  1821.     Decode43;
  1822.   CloseDataFiles
  1823. END.
  1824.  
  1825.  
  1826.